home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 08 - 1992 / 08.02 Jun 92 / Jörg's Folder / array_process.f next >
Encoding:
Text File  |  1992-01-20  |  2.0 KB  |  92 lines  |  [TEXT/MPS ]
  1. !!M Inlines.f
  2. !!G AEvent.finc
  3. c
  4. c
  5.     program Array_process
  6.  
  7.     implicit none
  8.     
  9.     external get_array
  10.     integer*2 err
  11.     
  12.     err = AEInstallEventHandler (%val('JLMT'),%val('MULT'),%val(%loc(get_array)),%val(int4(0)),%val(int2(0))) 
  13.     if (err. ne. 0) call alertbox('Array_process: Apple Event install error')
  14.  
  15.     do while (.true.)
  16.         call F_DoBackground
  17.     end do
  18.     
  19.     end
  20.  
  21.     integer*2 function get_array(theAppleEvent,reply,%val(handlerRefCon))
  22.     implicit none
  23.     
  24.     record /AppleEvent/ theAppleEvent
  25.     record /AppleEvent/ reply
  26.     integer*4 handlerRefCon
  27.     
  28.     integer*2 err
  29.     integer*4 keywd,returnedType,actualSize
  30.     
  31.     real*4 myarray(10000)
  32.  
  33.     integer xdim,ydim
  34.     global xdim,ydim,myarray
  35.     
  36.     integer totalsize
  37.     
  38.     err = AEGetParamPtr(%ref(theAppleEvent),%val('XDIM'),%val(typeInteger),
  39.     1        returnedType,%val(%loc(xdim)),%val(sizeof(xdim)),actualSize)
  40.     if (err    .ne. 0) goto 9999
  41.     
  42.     err = AEGetParamPtr(%ref(theAppleEvent),%val('YDIM'),%val(typeInteger),
  43.     1        returnedType,%val(%loc(ydim)),%val(sizeof(ydim)),actualSize)
  44.     if (err    .ne. 0) goto 9999
  45.     
  46.     totalsize = xdim * ydim * 4
  47.     
  48.     err = AEGetParamPtr(%ref(theAppleEvent),%val('ARRY'),%val(typeChar),
  49.     1        returnedType,%val(%loc(myarray)),%val(totalsize),actualSize)
  50.     if (err    .ne. 0) goto 9999
  51.  
  52. c    we don't check whether actualSize = totalsize and returnedType = typeChar.
  53. c
  54. c    In an actual application, such errors have to be trapped, of course.
  55. c
  56.  
  57.     call process_array(myarray,xdim,ydim)
  58.     
  59.     err = AEPutParamPtr(%ref(reply),%val('XDIM'),%val(typeInteger),
  60.     1        %val(%loc(xdim)),%val(sizeof(xdim)))
  61.     if (err    .ne. 0) goto 9999
  62.     
  63.     err = AEPutParamPtr(%ref(reply),%val('YDIM'),%val(typeInteger),
  64.     1        %val(%loc(ydim)),%val(sizeof(ydim)))
  65.     if (err    .ne. 0) goto 9999
  66.     
  67.     err = AEPutParamPtr(%ref(reply),%val('ARRY'),%val(typeChar),
  68.     1        %val(%loc(myarray)),%val(totalsize))
  69.     if (err    .ne. 0) goto 9999
  70.     
  71.     get_array = 0    ! noErr
  72.     return
  73.  
  74. 9999  get_array = err
  75.     return
  76.         
  77.     end
  78.  
  79.  
  80.     subroutine process_array(array,xdim,ydim)
  81.     integer xdim,ydim
  82.     real*4 array(xdim,ydim)
  83.     
  84.     do i=1,xdim
  85.         do j=1,ydim
  86.         array(i,j) = array(i,j)*array(i,j)/10000.
  87.         end do
  88.     end do
  89.     
  90.     return
  91.     end
  92.